home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / misc / sort2.lsp < prev   
Encoding:
Lisp/Scheme  |  1991-10-22  |  2.2 KB  |  41 lines
  1. ; Eine Sortierfunktion, sortiert eine Liste und streicht dabei Doppelte.
  2. ; Für list destruktiv.
  3. ; comparefun realisiert eine Totalordnung: -1 oder 0 oder +1 als Ergebnis.
  4. ; Dabei gelten zwei Listenelemente als gleich, wenn comparefun 0 liefert.
  5. (defun sort-list-deleting-duplicates (list comparefun &key (key #'identity))
  6.   (if (endp list)
  7.     list ; leere Liste unverändert
  8.     (labels ((sort-part (list)
  9.                (let ((len (length list)))
  10.                  (case len
  11.                    (1 list) ; einelementige Liste unverändert
  12.                    (2 (case (funcall comparefun (funcall key (first list)) (funcall key (second list)))
  13.                         (-1 list) ; Liste ist bereits sortiert
  14.                         (0 (cdr list)) ; zwei gleiche, wird verkürzt
  15.                         (+1 (setf (cddr list) list) (shiftf (cdr list) nil)) ; vertauschen
  16.                    )  )
  17.                    (t ; Liste mit >=2 Elementen
  18.                       ; auseinanderdividieren in zwei Teile:
  19.                       (let ((L1 list)
  20.                             (L2 (shiftf (cdr (nthcdr (1- (ash len -1)) list)) nil)))
  21.                         ; einzeln sortieren:
  22.                         (setq L1 (sort-part L1))
  23.                         (setq L2 (sort-part L2))
  24.                         ; Nun sind L1 und L2 (jedes für sich) sortiert und ohne Doppelte.
  25.                         ; zusammenmischen, dabei sortiert halten und gemeinsame Elemente
  26.                         ; von L1 und L2 nur einmal übernehmen (dadurch enthält dann
  27.                         ; auch die Gesamtliste keine Doppelten):
  28.                         (setq list nil)
  29.                         (loop
  30.                           (when (null L1) (return (nreconc list L2)))
  31.                           (when (null L2) (return (nreconc list L1)))
  32.                           (case (funcall comparefun (funcall key (first L1)) (funcall key (first L2)))
  33.                             (-1 (rotatef list L1 (cdr L1)))
  34.                             (0 (pop L1) (rotatef list L2 (cdr L2)))
  35.                             (+1 (rotatef list L2 (cdr L2)))
  36.                         ) )
  37.             )) ) ) )  )
  38.       (sort-part list)
  39. ) ) )
  40.  
  41.